home *** CD-ROM | disk | FTP | other *** search
/ Australian Personal Computer 2002 November / CD 1 / APC0211D1.ISO / workshop / prog / files / ActivePerl-5.6.1.633-MSWin32.msi / _6ffd2f74be220ad04737a170e30c5653 < prev    next >
Encoding:
Text File  |  2002-06-17  |  34.6 KB  |  1,185 lines

  1. package PPM::UI;
  2.  
  3. use strict;
  4. use Data::Dumper;
  5. use PPM::Repository;
  6. use PPM::Installer;
  7. use PPM::Config;
  8. use PPM::Trace qw(trace);
  9. use PPM::Result qw(Ok Warning Error List);
  10.  
  11. $PPM::UI::VERSION = '3.00';
  12.  
  13. my $CONF;
  14. my $TARG;
  15. my $REPS;
  16.  
  17. #=============================================================================
  18. # Name indexes into arrays:
  19. #=============================================================================
  20. use constant PROP_PPD_OBJ => 0;
  21. use constant PROP_INSTDATE => 1;
  22. use constant PROP_REPOS => 2;
  23.  
  24. use constant QUERY_NAME => 0;
  25. use constant QUERY_VERSION => 1;
  26. use constant QUERY_ABSTRACT => 2;
  27. use constant QUERY_AUTHOR => 3;
  28.  
  29. use constant CONF_INFO_KEY => 0;
  30. use constant CONF_INFO_VAL => 1;
  31.  
  32. use constant CONF_KEYS_KEY => 0;
  33. use constant CONF_KEYS_RW => 1;
  34.  
  35. use constant REP_INFO_NAME => 0;
  36. use constant REP_INFO_LOC => 1;
  37. use constant REP_INFO_TYPE => 2;
  38.  
  39. #=============================================================================
  40. # Configuration Options
  41. #=============================================================================
  42.  
  43. my %config_keys;
  44. BEGIN {
  45.    %config_keys = (tempdir => 1,
  46.            downloadbytes => 1,
  47.            tracefile => 1,
  48.            tracelvl => 1,
  49.            profile  => 1,
  50.            profile_server => 0,
  51.            profile_enable => 1,
  52.           );
  53. }
  54.  
  55. sub config_keys {
  56.     trace(3, "PPM::UI::config_keys()\n");
  57.     List(map { [$_ => $config_keys{$_}] } keys %config_keys);
  58. }
  59.  
  60. sub config_info {
  61.     trace(3, "PPM::UI::config_info()\n");
  62.     List(map { [$_ => $CONF->{DATA}{$_}] } keys %config_keys);
  63. }
  64.  
  65. sub config_set {
  66.     my $key = shift;
  67.     my $val = shift;
  68.     trace(3, "PPM::UI::config_set($key, $val)\n");
  69.     return Error("no such config key '$key'")
  70.       unless exists $config_keys{$key};
  71.     return Error("read-only configuration key '$key'")
  72.       unless $config_keys{$key};
  73.     $CONF->{DATA}{$key} = $val;
  74.     $CONF->save;
  75.     return Ok();
  76. }
  77.  
  78. sub config_get {
  79.     my $key = shift;
  80.     trace(3, "PPM::UI::config_get($key)\n");
  81.     return Error("no such config key '$key'.")
  82.       unless exists $config_keys{$key};
  83.     return Ok($CONF->{DATA}{$key});
  84. }
  85.  
  86. #=============================================================================
  87. # Repositories
  88. #=============================================================================
  89.  
  90. sub repository_list {
  91.     trace(3, "PPM::UI::repository_list()\n");
  92.     return List(sort keys %{$REPS->{DATA}});
  93. }
  94.  
  95. sub repository_add {
  96.     my $name = shift;
  97.     my $location = shift;
  98.     my $username = shift;
  99.     my $password = shift;
  100.     trace(3, "PPM::UI::repository_add($name, $location, ", $username,
  101.       ", ", $password, ")\n");
  102.  
  103.     # Validate it:
  104.     my ($r, $er) = PPM::Repository->new($location, $name, $username, $password);
  105.     return Error($er)
  106.       unless $r;
  107.  
  108.     $REPS->{DATA}{$name}{url} = $location;
  109.     $REPS->{DATA}{$name}{username} = $username if defined $username;
  110.     $REPS->{DATA}{$name}{password} = $password if defined $password;
  111.     $REPS->save;
  112.     return Ok();
  113. }
  114.  
  115. sub repository_del {
  116.     my $name = shift;
  117.     trace(3, "PPM::UI::repository_del($name)\n");
  118.     return Error("Can't delete nonexistent repository '$name'.")
  119.       unless exists $REPS->{DATA}{$name};
  120.     delete $REPS->{DATA}{$name};
  121.     $REPS->save;
  122.     del_rep($name);
  123.     return Ok();
  124. }
  125.  
  126. sub repository_rename {
  127.     my $oldname = shift;
  128.     my $newname = shift;
  129.     trace(3, "PPM::UI::repository_rename($oldname, $newname)\n");
  130.     $REPS->{DATA}{$newname} = $REPS->{DATA}{$oldname}
  131.       if exists $REPS->{DATA}{$oldname};
  132.     repository_del($oldname);
  133. }
  134.  
  135. sub repository_info {
  136.     my $name = shift;
  137.     trace(3, "PPM::UI::repository_info($name)\n");
  138.     return Error("Can't describe nonexistent repository '$name'.")
  139.       unless exists $REPS->{DATA}{$name};
  140.     my $rep = get_rep($name);
  141.     if ($rep->ok) {
  142.     $rep = $rep->result;
  143.     return List(
  144.         $name,
  145.         $rep->location,
  146.         $rep->type_printable,
  147.         $rep->username,
  148.         $rep->password,
  149.     );
  150.     }
  151.     else {
  152.     return Warning($rep->msg_raw,
  153.                -1,
  154.                [$name,
  155.             $REPS->{DATA}{$name}{url},
  156.             'unsupported']);
  157.     }
  158. }
  159.  
  160. #=============================================================================
  161. # Operations on non-installed packages
  162. #=============================================================================
  163.  
  164. sub search {
  165.     my $rlist = shift;
  166.     @$rlist = map { $_->result } grep { $_->ok } map { get_rep($_) } @$rlist;
  167.     my $target = get_targ(shift);
  168.     return $target unless $target->ok;
  169.     $target = $target->result;
  170.     my $query = shift;
  171.     my $case = shift;
  172.     my @results;
  173.     for my $r (@$rlist) {
  174.     my $l = $r->search($target, $query, $case);
  175.     next unless $l->ok;
  176.     push @results, map { get_pkg($_, $r) } $l->result_l;
  177.     }
  178.     return List(@results);
  179. }
  180.  
  181. sub describe {
  182.     my $rlist = shift;
  183.     @$rlist = map { $_->result } grep { $_->ok } map { get_rep($_) } @$rlist;
  184.     my $target = get_targ(shift);
  185.     return $target unless $target->ok;
  186.     $target = $target->result;
  187.     my $pkg = get_pkg(shift, $rlist);
  188.     my $package = $pkg->name;
  189.     my $desc = $pkg->describe($target);
  190.     return $desc unless $desc->ok;
  191.     return Ok(get_pkg($desc->result, $rlist));
  192. }
  193.  
  194. sub install {
  195.     my $rlist = shift;
  196.     @$rlist = map { $_->result } grep { $_->ok } map { get_rep($_) } @$rlist;
  197.     my $target = get_targ(shift);
  198.     return $target unless $target->ok;
  199.     $target = $target->result;
  200.     my $pkg = get_pkg(shift, $rlist);
  201.     my $opts = shift;
  202.     my $status_cb = shift;
  203.  
  204.     # Find the correct target for this package. This means matching the
  205.     # LANGUAGE tag in the PPD. Basically we find out what LANGUAGE the PPD
  206.     # represents, and we search through the targets looking for a subset which
  207.     # implement that language. If more than one target implements the language
  208.     # and version, we pick the first. If none work, we fail. If the LANGUAGE
  209.     # tag is missing, or the LANGUAGE matches the given target, we use the
  210.     # given target.
  211.     $target = $pkg->choose_target($target, target_list()->result_l);
  212.     return $target unless $target->ok;
  213.     $target = $target->result;
  214.     install_or_upgrade($rlist, $target, $pkg, $opts, $status_cb, 'install');
  215. }
  216.  
  217. #=============================================================================
  218. # Targets
  219. #=============================================================================
  220.  
  221. sub target_list {
  222.     trace(3, "PPM::UI::target_list()\n");
  223.     return List(sort keys %{$TARG->{DATA}});
  224. }
  225.  
  226. sub target_info {
  227.     my $target = shift;
  228.     trace(3, "PPM::UI::target_info($target)\n");
  229.     my $t = get_targ($target);
  230.     return $t unless $t->ok;
  231.     $t = $t->result;
  232.     my @keys = map { "\u$_" } $t->ckeys;
  233.     my @vals = $t->cvals;
  234.     my %hash;
  235.     @hash{@keys} = @vals;
  236.     return Ok(\%hash);
  237. }
  238. sub target_raw_info {
  239.     my $target = shift;
  240.     return Ok($TARG->{DATA}{$target});
  241. }
  242.  
  243. sub target_config_info {
  244.     my $target = get_targ(shift);
  245.     return $target unless $target->ok;
  246.     $target = $target->result;
  247.     trace(3, "PPM::UI::target_config_info(", $target->name, ")\n");
  248.     return $target->config_info;
  249. }
  250.  
  251. sub target_config_keys {
  252.     my $target = get_targ(shift);
  253.     return $target unless $target->ok;
  254.     $target = $target->result;
  255.     trace(3, "PPM::UI::target_config-keys(", $target->name, ")\n");
  256.     return $target->config_keys;
  257. }
  258.  
  259. sub target_config_get {
  260.     my $target = get_targ(shift);
  261.     return $target unless $target->ok;
  262.     $target = $target->result;
  263.     my $key = shift;
  264.     trace(3, "PPM::UI::target_config_get(", $target->name, ", $key)\n");
  265.     return $target->config_get($key);
  266. }
  267.  
  268. sub target_config_set {
  269.     my $target = get_targ(shift);
  270.     return $target unless $target->ok;
  271.     $target = $target->result;
  272.     my $key = shift;
  273.     my $value = shift;
  274.     trace(3, "PPM::UI::target_config_get(", $target->name, ", $key, $value)\n");
  275.     return $target->config_set($key, $value);
  276. }
  277.  
  278. sub target_rename {
  279.     my $oldname = shift;
  280.     my $newname = shift;
  281.  
  282.     # Make sure the target even exists:
  283.     my @targets = target_list()->result_l;
  284.     return Error("Can't rename nonexistent target '$oldname'.")
  285.       unless grep { $_ eq $oldname } @targets;
  286.  
  287.     # Load the targets file read/write:
  288.     {
  289.     my $t = PPM::Config::load_config_file('targets', 'rw');
  290.     $t->{DATA}{$newname} = $t->{DATA}{$oldname};
  291.     delete $t->{DATA}{$oldname};
  292.     }
  293.     $TARG = PPM::Config::load_config_file('targets', 'ro');
  294.  
  295.     # Return success if profile tracking is disabled.
  296.     return Ok() unless config_get('profile_enable')->result;
  297.  
  298.     # We must rename the target in all profiles:
  299.     my $res = profile_list();
  300.     unless ($res->is_success) {
  301.     return Error(
  302.         "failed to rename target in profiles: " . $res->msg_raw
  303.     ) unless $res->ok;
  304.     }
  305.     my @profiles = $res->result_l;
  306.  
  307.     my $repos = get_rep(config_get('profile_server')->result);
  308.     return $repos unless $repos->ok;
  309.     $repos = $repos->result;
  310.     for my $profile (@profiles) {
  311.     my $r = $repos->profile_target_rename($profile, $oldname, $newname);
  312.     return Error(
  313.         "failed to rename target in profiles: " . $r->msg_raw
  314.     ) unless $r->ok;
  315.     }
  316.  
  317.     Ok();
  318. }
  319.  
  320. sub target_fix_paths {
  321.     my $from = shift;
  322.     my $to   = shift;
  323.     my $i    = $^O eq 'MSWin32' ? '(?i)' : '';
  324.     {
  325.     my $t    = PPM::Config::load_config_file('targets', 'rw');
  326.     for my $targ (target_list()->result_l) {
  327.         for my $key (keys %{$t->{DATA}{$targ}}) {
  328.         $t->{DATA}{$targ}{$key} =~ s{$i\Q$from\E}{$to};
  329.         }
  330.     }
  331.     }
  332.     $TARG = PPM::Config::load_config_file('targets', 'ro');
  333. }
  334.  
  335. sub target_add {
  336.     my $name = shift;
  337.     my %opts = @_;
  338.  
  339.     # Handle loading a file:
  340.     if (not defined $name and -f $opts{From}) {
  341.     my $t = PPM::Config->new;
  342.     $t->loadfile($opts{From});
  343.     # There's only ever 1 target in that config file:
  344.     ($name) = keys %{$t->{DATA}};
  345.     %opts = %{$t->{DATA}{$name}};
  346.     }
  347.     return Error("can't add existing target '$name'")
  348.     if exists $TARG->{DATA}{$name};
  349.  
  350.     # Find an unused Port:
  351.     require PPM::Compat;
  352.     $opts{port} = PPM::Compat::PPM_PORT_PERL();
  353.     ++$opts{port} while (
  354.     grep { $opts{port} eq $TARG->{DATA}{$_}{port} }
  355.     keys %{$TARG->{DATA}}
  356.     );
  357.  
  358.     # Save the file:
  359.     {
  360.     my $t = PPM::Config::load_config_file('targets', 'rw');
  361.     $t->{DATA}{$name} = \%opts;
  362.     }
  363.     $TARG = PPM::Config::load_config_file('targets', 'ro');
  364.     return Ok();
  365. }
  366.  
  367. sub target_del {
  368.     my $name = shift;
  369.     return Error("can't delete nonexistent target '$name'")
  370.     unless exists $TARG->{DATA}{$name};
  371.     {
  372.     my $t = PPM::Config::load_config_file('targets', 'rw');
  373.     delete $t->{DATA}{$name};
  374.     }
  375.     $TARG = PPM::Config::load_config_file('targets', 'ro');
  376.     return Ok();
  377. }
  378.  
  379. #=============================================================================
  380. # Operations on installed packages
  381. #=============================================================================
  382.  
  383. sub query {
  384.     my $target = get_targ(shift);
  385.     return $target unless $target->ok;
  386.     $target = $target->result;
  387.     my $query = shift;
  388.     my $case = shift;
  389.     trace(3, "PPM::UI::query(", $target->name, ", '$query', $case)\n");
  390.     my @results = map { get_pkg($_) }
  391.           $target->query($query, $case)->result_l;
  392.     List(@results);
  393. }
  394.  
  395. sub properties {
  396.     my $target = get_targ(shift);
  397.     return $target unless $target->ok;
  398.     $target = $target->result;
  399.     my $pkg = get_pkg(shift, undef); # don't care about repository.
  400.     trace(3, "PPM::UI::properties(", $target->name, ", ", $pkg->name, ")\n");
  401.     my $res = $target->properties($pkg->name);
  402.     return $res unless $res->ok;
  403.     my @res = $res->result_l;
  404.     $res[0] = get_pkg($res[0]);
  405.     return List(@res);
  406. }
  407.  
  408. sub remove {
  409.     my $target = get_targ(shift);
  410.     return $target unless $target->ok;
  411.     $target = $target->result;
  412.     my $pkg = get_pkg(shift, undef); # don't care about repository.
  413.     my $package = $pkg->name;
  414.     my $force = shift;  # normally, if removing a package would break a
  415.             # dependency of another installed package, we refuse.
  416.             # But if the user really wants to...
  417.     my $cb_remove = shift;
  418.     my $verbose = shift;
  419.  
  420.     trace(3, "PPM::UI::remove(", $target->name, ", $package)\n");
  421.     if (grep { $pkg->name eq $_ } $target->precious->result_l) {
  422.     return Error("package '$package' is required by the target.");
  423.     }
  424.     my $prop = $target->properties($package);
  425.     return $prop unless $prop->ok;
  426.  
  427.     my $ok = $target->dependents($package);
  428.     return $ok unless $ok->ok;
  429.  
  430.     my @deps = $ok->result_l;
  431.     if (@deps and not $force) {
  432.     my $msg = "removing '$package' would break these dependencies:\n";
  433.     $msg .= "\t$package is needed by $_.\n" for @deps;
  434.     return Error($msg);
  435.     }
  436.  
  437.     my $version = ($prop->result_l)[PROP_PPD_OBJ]->version;
  438.     $cb_remove->($package, $version, $target->name, "PRE-REMOVE");
  439.     my $ret = $target->remove($package, $verbose);
  440.     return $ret unless $ret->ok;
  441.     $cb_remove->($package, $version, $target->name, "COMPLETE");
  442.     my $track = config_get('profile_enable')->result;
  443.     if ($track and $ret->ok) {
  444.     my $repos = get_rep(config_get('profile_server')->result);
  445.     return $repos unless $repos->ok;
  446.     $repos = $repos->result;
  447.     my $rep = ($prop->result_l)[PROP_REPOS];
  448.     my $ver = ($prop->result_l)[PROP_PPD_OBJ]->version_osd;
  449.     my $entry = [$rep,
  450.              $target->config_get('TARGET_TYPE')->result,
  451.              $target->name,
  452.              $package,
  453.              $ver
  454.             ];
  455.     my $profile = config_get('profile')->result;
  456.     $repos->removed($profile, $entry);
  457.     }
  458.     $ret;
  459. }
  460.  
  461. sub verify {
  462.     my $rlist = shift;
  463.     @$rlist = map { $_->result } grep { $_->ok } map { get_rep($_) } @$rlist;
  464.     my $target = get_targ(shift);
  465.     return $target unless $target->ok;
  466.     $target = $target->result;
  467.     my $pkg = get_pkg(shift, $rlist);
  468.     my $package = $pkg->name;
  469.     trace(3, "PPM::UI::verify(", $target->name, ", $package)\n");
  470.  
  471.     # To do: 
  472.     # 1. Check if the package is installed; return false otherwise.
  473.     my $prop = $target->properties($package);
  474.     return $prop unless $prop->ok;
  475.     my @prop = $prop->result_l;
  476.  
  477.     my $bundled  = grep { $prop[PROP_PPD_OBJ]->name eq $_ }
  478.                 $target->bundled->result_l;
  479.     my $precious = grep { $prop[PROP_PPD_OBJ]->name eq $_ }
  480.                 $target->precious->result_l;
  481.  
  482.     # 2. Get the installed version of the package.
  483.     my $ver = $prop[PROP_PPD_OBJ]->version_osd;
  484.     my $ver_p = $prop[PROP_PPD_OBJ]->version;
  485.  
  486.     # 3. Send the installed version to the Repository for checking.
  487.     # XXX
  488.     # I used to only upgrade from the place it came from. Now it will come
  489.     # from the current repository.
  490.     my $res = $pkg->uptodate($target);
  491.     unless ($res->ok) {
  492.     return Error("bundled package - no upgrade available")
  493.       if $bundled;
  494.     return $res;
  495.     }
  496.     my ($uptodate, $newversion) = $res->result_l;
  497.  
  498.     # 4. Return uptodate(t/f), newversion, oldversion, bundled(t/f):
  499.     return List($uptodate, $bundled, $precious, $newversion, $ver_p);
  500. }
  501.  
  502. sub upgrade {
  503.     my $rlist = shift;
  504.     @$rlist = map { $_->result } grep { $_->ok } map { get_rep($_) } @$rlist;
  505.     my $target = get_targ(shift);
  506.     return $target unless $target->ok;
  507.     $target = $target->result;
  508.     my $pkg = get_pkg(shift, $rlist);
  509.     my $package = $pkg->name;
  510.     my $opts = shift;
  511.     my $status_cb = shift;
  512.  
  513.     trace(3, "PPM::UI::upgrade(", $target->name,
  514.       ", $package, $opts->{force}, $opts->{follow}, $opts->{dryrun})\n");
  515.  
  516.     install_or_upgrade($rlist, $target, $pkg, $opts, $status_cb, 'upgrade');
  517. }
  518.  
  519. #=============================================================================
  520. # Operations which require you to have logged in
  521. #=============================================================================
  522.  
  523. sub profile_set {
  524.     my $profile = shift;
  525.     trace(3, "PPM::UI::profile_set($profile)\n");
  526.     config_set('profile', $profile);
  527.     Ok();
  528. }
  529.  
  530. sub profile_get {
  531.     trace(3, "PPM::UI::profile_get()\n");
  532.     config_get('profile');
  533. }
  534.  
  535. sub profile_list {
  536.     trace(3, "PPM::UI::profile_list()\n");
  537.     my $p_rep = config_get('profile_server')->result;
  538.     my $rep = get_rep($p_rep);
  539.     return $rep unless $rep->ok;
  540.     $rep = $rep->result;
  541.     $rep->profile_list;
  542. }
  543.  
  544. sub profile_add {
  545.     my $profile = shift;
  546.     trace(3, "PPM::UI::profile_add($profile)\n");
  547.     my $p_rep = config_get('profile_server')->result;
  548.     my $rep = get_rep($p_rep);
  549.     return $rep unless $rep->ok;
  550.     $rep = $rep->result;
  551.     $rep->profile_add($profile);
  552. }
  553.  
  554. sub profile_del {
  555.     my $profile = shift;
  556.     trace(3, "PPM::UI::profile_del($profile)\n");
  557.     my $p_rep = config_get('profile_server')->result;
  558.     my $rep = get_rep($p_rep);
  559.     return $rep unless $rep->ok;
  560.     $rep = $rep->result;
  561.     $rep->profile_del($profile);
  562. }
  563.  
  564. sub profile_restore {
  565.     my $profile = shift;
  566.     my $status_cb = shift;
  567.     my $remove_cb = shift;
  568.     my $force = shift;
  569.     my $follow = shift;
  570.     my $dry = shift;
  571.     my $clean_pkgs = shift;
  572.  
  573.     trace(3, "PPM::UI::profile_restore($profile, CODEREF, ",
  574.       "$force, $follow, $dry, $clean_pkgs)\n");
  575.  
  576.     my $p_rep = config_get('profile_server')->result;
  577.     my $rep = get_rep($p_rep);
  578.     return $rep unless $rep->ok;
  579.     $rep = $rep->result;
  580.  
  581.     # 1. Download the profile_info() from the repository
  582.     my $res = $rep->profile_info($profile);
  583.     return $res unless $res->ok;
  584.  
  585.     my %packages;
  586.  
  587.     # 2. For each package in profile_info(), upgrade (or install)
  588.     for my $entry ($res->result_l) {
  589.     my ($repos, $targ_type, $targ_name, $package, $version) = @$entry;
  590.     my $rep = get_rep($repos);
  591.     return $rep unless $rep->ok;
  592.     $rep = $rep->result;
  593.     my $targ = get_targ($targ_name)->result;
  594.     next unless $targ;    # skip unknown targs
  595.  
  596.     $packages{$targ->name}{$package} = $version;
  597.  
  598.     my $prop = properties($targ_name, $package);
  599.     next if ($prop->ok
  600.          and ($prop->result_l)[PROP_PPD_OBJ]->version_osd eq $version);
  601.  
  602.     if ($dry) {
  603.         my $version = PPM::PPD::printify($version);
  604.         $status_cb->($package, $version, $targ->name,
  605.              'PRE-INSTALL', 0, 0, 0);
  606.     }
  607.     else {
  608.         remove($targ_name, $package, 1, $remove_cb)
  609.           if $prop->ok;
  610.         install($rep, $targ_name, $package, $force, $follow, $dry, $status_cb);
  611.     }
  612.     }
  613.  
  614.     return Ok() unless $clean_pkgs;
  615.  
  616.     # 3. Now query each target and make sure it only contains the packages we
  617.     # just installed (if clean_pkgs is set):
  618.     for my $target (keys %packages) {
  619.     my @precious = get_targ($target)->result->precious->result_l;
  620.     my $q = query($target, '*', 0);
  621.     next unless $q->ok;
  622.     for my $pkg ($q->result_l) {
  623.         next if exists $packages{$target}{$pkg->name};
  624.         next if grep { $pkg->name eq $_ } @precious;
  625.         if ($dry) {
  626.         $remove_cb->($pkg->name, $pkg->version, $target);
  627.         }
  628.         else {
  629.         remove($target, $pkg->name, 1, $remove_cb);
  630.         }
  631.     }
  632.     }
  633.  
  634.     return Ok();
  635. }
  636.  
  637. sub profile_save {
  638.     my $name = shift;
  639.     trace(3, "PPM::UI::profile_save($name)\n");
  640.  
  641.     my $p_rep = config_get('profile_server')->result;
  642.     my $rep = get_rep($p_rep);
  643.     return $rep unless $rep->ok;
  644.     $rep = $rep->result;
  645.  
  646.     # 1. Get the "query *" information from all current targets.
  647.     my @entries;
  648.  
  649.     # First, get the targets:
  650.     my @targets = map { get_targ($_)->result } target_list()->result_l;
  651.     for my $targ (@targets) {
  652.  
  653.     # Now get information about that target:
  654.     my $targ_t = $targ->config_get("TARGET_TYPE")->result;
  655.     my $targ_name = $targ->name;
  656.  
  657.     # Now get the packages:
  658.     my @pkgs = query($targ, '*', 0)->result_l;
  659.     for my $pkg (@pkgs) {
  660.         my $obj = $pkg->getppd_obj;
  661.         next unless $obj->ok;
  662.         my $prop = properties($targ, $pkg->name);
  663.         my $repos = ($prop->result_l)[PROP_REPOS];
  664.         my $entry = [$repos,
  665.              $targ_t,
  666.              $targ_name,
  667.              $pkg->name,
  668.              $obj->result->version_osd,
  669.             ];
  670.         push @entries, $entry;
  671.     }
  672.     }
  673.  
  674.     # 2. Upload the information to the Repository.
  675.     $rep->profile_save($name, @entries);
  676. }
  677.  
  678. sub profile_info {
  679.     my $name = shift;
  680.     trace(3, "PPM::UI::profile_info($name)\n");
  681.     my $p_rep = config_get('profile_server')->result;
  682.     my $rep = get_rep($p_rep);
  683.     return $rep unless $rep->ok;
  684.     $rep = $rep->result;
  685.     my $res = $rep->profile_info($name);
  686.     return $res unless $res->ok;
  687.     my @lst = $res->result_l;
  688.     my @ret;
  689.     for (@lst) {
  690.     my $ent = [@$_[qw(3 4 2)]];
  691.     $ent->[1] = PPM::PPD::printify($ent->[1]);
  692.     push @ret, $ent;
  693.     }
  694.     List(@ret);
  695. }
  696.  
  697. sub profile_rename {
  698.     my $oldname = shift;
  699.     my $newname = shift;
  700.  
  701.     # Make sure the profile actually exists:
  702.     my @profiles = profile_list()->result_l;
  703.     return Error("Can't rename nonexistent repository '$oldname'.")
  704.       unless grep { $oldname eq $_ } @profiles;
  705.  
  706.     # Tell the server to rename the profile:
  707.     my $repos = get_rep(config_get('profile_server')->result);
  708.     return $repos unless $repos->ok;
  709.     $repos = $repos->result;
  710.     $repos->profile_rename($oldname, $newname);
  711. }
  712.  
  713. #=============================================================================
  714. # Utilities
  715. #=============================================================================
  716. sub install_or_upgrade {
  717.     my $rlist = shift;      # A list of repositories to search in order
  718.     my $target = shift;
  719.     my $package = shift;
  720.     my $opts = shift;
  721.     my %opts = %$opts;
  722.     my $status_cb = shift;
  723.     my $event_name = shift;
  724.  
  725.     my $do_install = sub {
  726.     my $pkg = shift;
  727.  
  728.     # Download the PPD and package tarball:
  729.     my $pkg_obj = $pkg->getppd_obj($target)->result;
  730.     if ($opts{dryrun}) {
  731.         $status_cb->($pkg->name, $pkg_obj->version,
  732.              $target->name, 'PRE-INSTALL', 0, 0, 0);
  733.         return Ok(); # do nothing, successfully
  734.     }
  735.     my $location = $pkg->getppm($target,
  736.                     config_get("tempdir")->result,
  737.                     $status_cb,
  738.                     config_get("downloadbytes")->result,
  739.                    );
  740.  
  741.     # update ERR appropriately, and fail.
  742.     return $location unless $location->ok;
  743.  
  744.     # Send the install (or update) event to the backend:
  745.     my $err = $target->$event_name($pkg_obj->name,
  746.                        $location->result,
  747.                        $pkg_obj->ppd,
  748.                        $pkg->rep->location,
  749.                        $opts{verbose},
  750.                       );
  751.     return $err unless $err->ok;
  752.  
  753.     $status_cb->($pkg->name, $pkg_obj->version, $target->name, "COMPLETE");
  754.  
  755.     # Track the profile:
  756.     my $track = config_get('profile_enable')->result;
  757.     if ($track) {
  758.         my $p_rep = get_rep(config_get('profile_server')->result);
  759.         my $ok = $p_rep;
  760.         my $profile = config_get('profile')->result;
  761.         if ($p_rep->ok) {
  762.         $p_rep = $p_rep->result;
  763.         my $entry = [$pkg->rep->location,
  764.                  $target->config_get('TARGET_TYPE')->result,
  765.                  $target->name,
  766.                  $pkg_obj->name,
  767.                  $pkg_obj->version_osd,
  768.                 ];
  769.         if ($event_name eq 'install') {
  770.             $ok = $p_rep->installed($profile, $entry);
  771.         }
  772.         else {
  773.             $ok = $p_rep->upgraded($profile, $entry);
  774.         }
  775.         }
  776.         unless ($ok->is_success) {
  777.         my $warning = Warning("Profile '$profile' may not be in sync. "
  778.                    . $ok->msg_raw);
  779.         return $warning;
  780.         }
  781.     }
  782.     return Ok();
  783.     };
  784.  
  785.     # We can shortcut the prerequisite check if we're ignoring that:
  786.     return $do_install->($package)
  787.       if ($opts{force} and not $opts{follow});
  788.  
  789.     my $warning = Ok();
  790.     my @pkgs = ($package);
  791.     my %done;
  792.  
  793.   PACKAGE:
  794.     while (@pkgs) {
  795.     my $pkg = shift @pkgs;
  796.  
  797.     # If the package is up to date (and $force isn't set), return.
  798.     my $prop = properties($target, $pkg);
  799.     if ($prop->ok) {
  800.         my $u2d = $pkg->uptodate($target);
  801.  
  802.         # If the server doesn't have that package available, we'll
  803.         # _assume_ it's up to date, issuing a warning to that effect
  804.         my $uptodate = 1;
  805.         if ($u2d->ok) {
  806.         ($uptodate) = $u2d->result_l;
  807.         }
  808.         else {
  809. #        print "NOTE: package " . $p->name . " not on server...\n";
  810. #        print Dumper $p, $u2d;
  811. #        print Dumper \@pkgs;
  812.         next PACKAGE;
  813.         }
  814.         next PACKAGE if ($uptodate and not $opts{force});
  815.     }
  816.  
  817.     # Try to get a list of prerequisites for the package:
  818.     my @missing;
  819.     my $ppd_ref = $pkg->getppd_obj($target);
  820.     return $ppd_ref unless $ppd_ref->ok;
  821.     my $impl = $ppd_ref->result->find_impl($target);
  822.     return $impl unless $impl->ok;
  823.     
  824.     # Get a list of prerequisites from the implementation:
  825.     my @prereqs = grep { not $done{$_->name} } $impl->result->prereqs;
  826.  
  827.     # We can shortcut the cross-checking of prereqs if we're forcing the
  828.     # install of any prereqs:
  829.     if ($opts{force} and $opts{follow} and @prereqs) {
  830.         unshift @pkgs, (map { get_pkg($_->name, $rlist) } @prereqs), $pkg;
  831.         next PACKAGE;
  832.     }
  833.     
  834.     # Check each prerequisite to see if it's installed.
  835.     else {
  836.         for my $pre (@prereqs) {
  837.         my $prop = $target->properties($pre->name);
  838.         push @missing, $pre->name and next
  839.           unless $prop->ok;
  840.         my $ver = ($prop->result_l)[PROP_PPD_OBJ]->version_osd;
  841.         my $ok = $pkg->uptodate($target, $pre->name, $ver);
  842.         push @missing, $pre->name
  843.           if ($ok->ok and not (($ok->result_l)[0]));
  844.         }
  845.         if (@missing and not $opts{force} and not $opts{follow}) {
  846.         return Error(
  847.             "can't install package '", $pkg->name,
  848.             "': missing prereqs @missing."
  849.         );
  850.         }
  851.         elsif (@missing) {
  852.         unshift @pkgs, (map { get_pkg($_, $rlist) } @missing), $pkg;
  853.         next PACKAGE;
  854.         }
  855.     }
  856.  
  857.     # Install the durned package
  858.     my $res = $do_install->($pkg);
  859.     return $res unless $res->ok;
  860.     $warning = $res unless $res->is_success;
  861.     $done{$pkg->name}++;
  862.     }
  863.     return $warning;
  864. }
  865.  
  866. #=============================================================================
  867. # These utilities make it easier for clients of this class to find out
  868. # information about packages. Any subroutine which takes the name of a package
  869. # can now take either a URL or a filename. That means clients may want to know
  870. # this!
  871. #=============================================================================
  872. sub get_pkg {
  873.     my $pkg = shift;
  874.     my $rep = shift;
  875.     return $pkg if eval { $pkg->isa('PPM::Package') };
  876.     PPM::Package->new($pkg, $rep);
  877. }
  878.  
  879. sub pkg_type {
  880.     my $pkg = get_pkg(shift, undef); # not going to use the repository
  881.     return $pkg->type;
  882. }
  883.  
  884. sub is_pkg {
  885.     my $pkg = shift;
  886.     return 1 if eval { $pkg->isa('PPM::Package') };
  887.     my $p = PPM::Package->new($pkg);
  888.     return 0 if $p->type eq 'UNKNOWN';
  889.     1;
  890. }
  891.  
  892. #=============================================================================
  893. # Cache of "active" repositories and targets:
  894. #=============================================================================
  895. my %open_repositories;
  896. sub get_rep {
  897.     my $rep = shift;
  898.     trace(3, "PPM::UI::get_rep($rep)\n");
  899.     return Ok($rep) if eval { $rep->isa("PPM::Repository") };
  900.     return Ok($open_repositories{$rep})
  901.       if exists $open_repositories{$rep};
  902.     my ($url,$name,$pass) = exists $REPS->{DATA}{$rep}
  903.               ? @{$REPS->{DATA}{$rep}}{qw(url username password)}
  904.               : ($rep, undef, undef);
  905.  
  906.     my @ok = PPM::Repository->new($url, $rep, $name, $pass);
  907.     return Error($ok[1]) unless $ok[0];
  908.     $open_repositories{$rep} = $ok[0];
  909.     Ok($ok[0]);
  910. }
  911. sub del_rep {
  912.     my $rep = shift;
  913.     delete $open_repositories{$rep};
  914. }
  915.  
  916. my %open_installers;
  917. sub get_targ {
  918.     my $targ = shift;
  919.     $targ = '' unless defined $targ;
  920.     trace(3, "PPM::UI::get_targ($targ)\n");
  921.     return Ok($targ) if eval { $targ->isa("PPM::Installer") };
  922.     return Ok($open_installers{$targ})
  923.       if exists $open_installers{$targ};
  924.     return Error("Target '$targ' not found")
  925.       unless exists $TARG->{DATA}{$targ};
  926.     my $t = $TARG->{DATA}{$targ};
  927.     my @r = PPM::Installer->new($targ, $t);
  928.     return Error($r[1]) unless $r[0];
  929.     $open_installers{$targ} = $r[0];
  930.     Ok($r[0]);
  931. }
  932.  
  933. #=============================================================================
  934. # Settings persistence
  935. #=============================================================================
  936. BEGIN {
  937.     $CONF = PPM::Config::load_config_file('clientlib');
  938.     $REPS = PPM::Config::load_config_file('repositories');
  939.     $TARG = PPM::Config::load_config_file('targets', 'ro');
  940.  
  941.     # Start up the trace if it's needed:
  942.     my $tracelvl = config_get('tracelvl');
  943.     if ($tracelvl->result && $tracelvl->result > 0) {
  944.     PPM::Trace::trace_init(config_get('tracefile')->result,
  945.                    config_get('tracelvl')->result);
  946.     }
  947. }
  948.  
  949. package PPM::Package;
  950. use strict;
  951. use PPM::Result qw(Ok Warning Error List);
  952. use URI;
  953. use Data::Dumper;
  954.  
  955. sub new {
  956.     my $class = shift;
  957.     my $name  = shift;
  958.     my $rep   = shift;
  959.     my $o = bless {}, ref($class) || $class;
  960.     $rep = [] if not defined $rep;
  961.  
  962.     # A PPM::PPD object
  963.     if (eval { $name->isa('PPM::PPD') }) {
  964.     $o->{type}    = 'PPM::PPD';
  965.     $o->{name}    = $o->{rawname} = $name->name;
  966.     $o->{id}      = $name->id;
  967.     $o->{current_rep} =
  968.         defined $name->repository ? $name->repository :
  969.         ref $rep eq 'ARRAY'       ? $rep->[0]         : $rep;
  970.     $o->{reps}    = [$o->{current_rep}];
  971.     $o->{obj}     = Ok($name);
  972.     }
  973.     # A URL:
  974.     elsif ($name =~ m{(^[^:]{2,}://.+)/([^/]+)\.ppd}i) {
  975.     $o->{type}    = 'WWW';
  976.     $o->{rawname} = $o->{id} = $2;
  977.     my $rep       = PPM::UI::get_rep($1);
  978.     $o->{uri}     = URI->new($name);
  979.     die "Can't parse PPD location $name: " . $rep->msg
  980.       unless $rep->is_success;
  981.     $o->{reps}    = [$rep->result];
  982.     my $ppd_obj   = $o->getppd_obj(undef); # undef'd target...
  983.     $o->{name}    = $o->{rawname} unless $ppd_obj->ok;
  984.     $o->{name}    = $ppd_obj->result->name;
  985.     }
  986.     # A filename:
  987.     elsif ($name =~ m{((?:^[A-Z]:[\\/]|[\\/]{2}[^\\/]+)?[^:]*[\\/])?([^/]+)\.ppd}i) {
  988.     $o->{type}    = 'FILE';
  989.     $o->{rawname} = $o->{id} = $2;
  990.     my $dir = $1;
  991.     $dir =~ s{[\\/]+$}{} if $dir and $dir !~ m{^[\\/]+$};
  992.     my $rep = PPM::UI::get_rep($dir || '.');
  993.     die "Can't parse PPD location $name: " . $rep->msg
  994.       unless $rep->is_success;
  995.     $o->{reps}  = [$rep->result];
  996.     my $ppd_obj = $o->getppd_obj(undef); # undef'd target...
  997.     if ($ppd_obj->ok) {
  998.         $o->{name} = $ppd_obj->result->name;
  999.     }
  1000.     else {
  1001.         $o->{name} = $o->{rawname} unless $ppd_obj->ok;
  1002.     }
  1003.     }
  1004.     # A plain package name:
  1005.     elsif ($name =~ m{^[-_A-Za-z0-9]+$}) {
  1006.     $o->{type} = 'PKG';
  1007.     $o->{name} = $o->{rawname} = $name;
  1008.     $o->{reps} = ref($rep) eq 'ARRAY' ? $rep : [$rep];
  1009.     }
  1010.     # Something else:
  1011.     else {
  1012.     #print STDERR "WARNING: could not parse package name '$name'.\n";
  1013.     $o->{type} = 'UNKNOWN';
  1014.     $o->{name} = $o->{rawname} = $name;
  1015.     $o->{reps} = ref($rep) eq 'ARRAY' ? $rep : [$rep];
  1016.     }
  1017.     $o->{id} = $o->{rawname} unless defined $o->{id};
  1018.  
  1019.     return $o;
  1020. }
  1021.  
  1022. sub name {
  1023.     my $o = shift;
  1024.     $o->{name};
  1025. }
  1026.  
  1027. sub reps {
  1028.     my $o = shift;
  1029.     @{$o->{reps}};
  1030. }
  1031.  
  1032. sub rep {
  1033.     my $o = shift;
  1034.     $o->{current_rep};
  1035. }
  1036.  
  1037. sub type {
  1038.     my $o = shift;
  1039.     $o->{type};
  1040. }
  1041.  
  1042. sub uri {
  1043.     my $o = shift;
  1044.     $o->{uri};
  1045. }
  1046.  
  1047. # Forces a refresh of the {obj} or {desc} fields if they are not marked as
  1048. # complete by the PPM::Repository client.
  1049. sub make_complete {
  1050.     my $o = shift;
  1051.     my $targ = PPM::UI::get_targ(shift)->result;
  1052.     my $obj = $o->getppd_obj($targ);
  1053.     return if $obj->ok && $obj->result->is_complete;
  1054.     delete @$o{qw(obj desc)};
  1055.     $o->{obj} = $o->{desc} = $o->getppd_obj($targ);
  1056. }
  1057.  
  1058. # Find the first repository containing the package, and report whether the
  1059. # package is up-to-date w.r.t that repository.
  1060. sub uptodate {
  1061.     my $o = shift;
  1062.     my $target = PPM::UI::get_targ(shift)->result;
  1063.     my $desc = $o->describe($target);
  1064.     if ($desc and $desc->ok) {
  1065.     my $u2d = $o->{current_rep}->uptodate(
  1066.         $target,
  1067.         $o->{id},
  1068.         $desc->result->version_osd,
  1069.     );
  1070.     return Ok(0) unless $u2d->ok;
  1071.     return Ok($u2d->result);
  1072.     }
  1073.     Error("package $o->{rawname} not found in repositories");
  1074. }
  1075.  
  1076. sub describe {
  1077.     my $o = shift;
  1078.     my $target = PPM::UI::get_targ(shift)->result;
  1079.     return $o->{obj}  if $o->{type} eq 'PPM::PPD';
  1080.     return $o->{desc} if $o->{desc};
  1081.     unless ($o->{desc}) {
  1082.     for my $rep (@{$o->{reps}}) {
  1083.         $o->{current_rep} = $rep;
  1084.         $o->{desc} = $rep->describe($target, $o->{id});
  1085.         last if $o->{desc}->ok;
  1086.     }
  1087.     }
  1088.     $o->{desc};
  1089. }
  1090.  
  1091. sub getppd_obj {
  1092.     my $o = shift;
  1093.     my $target = PPM::UI::get_targ(shift)->result;
  1094.     unless ($o->{obj}) {
  1095.     for my $rep (@{$o->{reps}}) {
  1096.         $o->{current_rep} = $rep;
  1097.         $o->{obj} = $rep->getppd_obj($target, $o->{id});
  1098.         last if $o->{obj}->ok;
  1099.     }
  1100.     }
  1101.     $o->{obj}
  1102. }
  1103.  
  1104. sub getppd {
  1105.     my $o = shift;
  1106.     my $target = PPM::UI::get_targ(shift)->result;
  1107.  
  1108.     # If the current object already has a complete PPD, use it
  1109.     return Ok($o->{obj}->result->ppd) if (
  1110.     $o->{obj} and
  1111.     $o->{obj}->ok and
  1112.     $o->{obj}->result->is_complete and
  1113.     $o->{obj}->result->ppd
  1114.     );
  1115.  
  1116.     # Otherwise download a fresh one
  1117.     my $ppd;
  1118.     for my $rep (@{$o->{reps}}) {
  1119.     $o->{current_rep} = $rep;
  1120.     $ppd = $rep->getppd($target, $o->{id});
  1121.     last if $ppd->ok;
  1122.     }
  1123.     $ppd;
  1124. }
  1125.  
  1126. sub getppm {
  1127.     my $o = shift;
  1128.     my $target = PPM::UI::get_targ(shift)->result;
  1129.     my $ppm;
  1130.     for my $rep (@{$o->{reps}}) {
  1131.     $o->{current_rep} = $rep;
  1132.     $ppm = $rep->getppm($target, $o->{id}, @_);
  1133.     last if $ppm->ok;
  1134.     }
  1135.     $ppm;
  1136. }
  1137.  
  1138. # Find the correct target for this package. This means matching the
  1139. # LANGUAGE tag in the PPD. Basically we find out what LANGUAGE the PPD
  1140. # represents, and we search through the targets looking for a subset which
  1141. # implement that language. If more than one target implements the language
  1142. # and version, we pick the first. If none work, we fail. If the LANGUAGE
  1143. # tag is missing, or the LANGUAGE matches the given target, we use the
  1144. # given target.
  1145. # NOTE: because LANGUAGE is a child-node of IMPLEMENTATION, we _first_ have to
  1146. # search for an implementation that matches the target, _then_ we have to
  1147. # verify that the target supports the LANGUAGE tag. If it does, we return it,
  1148. # otherwise we go on to the next target.
  1149. sub choose_target {
  1150.     my $o = shift;
  1151.     for (@_) {
  1152.     # Load the target:
  1153.     my $target = PPM::UI::get_targ($_);
  1154.     next unless $target->ok;
  1155.     $target = $target->result;
  1156.  
  1157.     # Load the PPD and find a suitable implementation for this target:
  1158.     my $ppd = $o->getppd_obj($target);
  1159.     return $ppd unless $ppd->ok;    # the package doesn't exist.
  1160.     my $impl = $ppd->result->find_impl($target);
  1161.     next unless $impl->ok;
  1162.     my $lang = $impl->result->language;
  1163.  
  1164.     # Older PPDs didn't have a LANGUAGE tag, so we must assume a Perl
  1165.     # implementation. For old-times' sake, we'll assume version 5.005 is
  1166.     # required.
  1167.     unless (defined $lang) {
  1168.         $lang = PPM::PPD::Language->new({
  1169.         NAME    => 'Perl',
  1170.         VERSION    => '5.6.0',
  1171.         });
  1172.     }
  1173.  
  1174.     # Check if this implementation's language is understood by the target:
  1175.     my $match = $lang->matches_target($target);
  1176.     return $match unless $match->ok;
  1177.     return Ok($target) if $match->result;
  1178.     }
  1179.     return Error(
  1180.     "no suitable installation target found for package $o->{name}."
  1181.     );
  1182. }
  1183.  
  1184. 1;
  1185.